home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / 3032.ZIP / RLIB20.ZIP / RL_PICKR.PRG < prev    next >
Text File  |  1989-08-23  |  12KB  |  324 lines
  1. * Function: PICKREC
  2. * Author..: Richard Low
  3. * Syntax..: PICKREC( top, left, bottom, right, output, proc, condition, row )
  4. * Notes...: Function for cursoring through a box-menu selection of records
  5. *           from the currently selected database, and selecting a record
  6. *           to work with by pressing the enter key.
  7. * Returns.: The row number of the selected record,  or zero if the Escape
  8. *           Key was pressed to exit.  If either the insert or delete keys
  9. *           are pressed, the routine exits to the calling procedure which
  10. *           can test for Insert or Delete with the LASTKEY() function.
  11. *
  12. * Assumes.: Expects to be passed the following parameters:
  13. *
  14. *           top       = exp<N> - top row of the box contents
  15. *           left      = exp<N> - top left column of box contents
  16. *           bottom    = exp<N> - bottom row of box contents
  17. *           right     = exp<N> - bottom column of box contents
  18. *           output    = exp<C> - character expression for output display
  19. *           proc      = exp<C> - Optional PROCEDURE to call on each keypress
  20. *           condition = exp<C> - Optional condition expression
  21. *           row       = exp<N> - current row number (used to reposition bar)
  22. *                              = 0 - GO TOP and fill the box with records
  23. *                              < 0 - erase box and re-fresh from current record
  24. *
  25. *           If a parameter is to be skipped, pass a 'dummy' parameter
  26. *           such as a null string in place of the actual parameter.
  27. *
  28. * Ex:  foutput = "Lastname + ', ' + Firstname"
  29. *
  30. *      rownum = PICKREC( 6, 40, 18, 78, foutput, 'REDISPLAY', '', rownum )
  31. *
  32.  
  33. FUNCTION PICKREC
  34. PARAMETERS p_top, p_left, p_bot, p_rite, p_output, p_proc, p_cond, p_row
  35. PRIVATE do_proc, num_cols, padding, mrec, lkey, counter, f_rowcount,;
  36.         in_color, f_bright, f_reverse, f_seekstr
  37.  
  38. *-- verify first 5 parameters given are correct type
  39. IF TYPE('p_top')  + TYPE('p_left') + TYPE('p_bot') +;
  40.    TYPE('p_rite') + TYPE('p_output') != 'NNNNC'
  41.    RETURN 0
  42. ENDIF
  43.  
  44. *-- verify procedure name is a character string
  45. p_proc  = IF( TYPE('p_proc') = 'C', p_proc, '' )
  46. do_proc = (.NOT. EMPTY(p_proc))
  47.  
  48.  
  49. *-- verify any condition given is  a character string
  50. p_cond  = IF( TYPE('p_cond') = 'C', p_cond, '.T.' )
  51.  
  52. *-- and that it evaluates to a logical answer
  53. IF TYPE(p_cond) != 'L'
  54.    p_cond = '.T.'
  55. ENDIF
  56.  
  57.  
  58. *-- get incoming color setting and build the bright and reverse settings
  59. in_color  = UPPER(SETCOLOR())
  60. f_bright  = BRIGHT(in_color)
  61. f_reverse = GETPARM(2,in_color)
  62.  
  63. SETCOLOR(in_color)
  64.  
  65. num_cols = p_rite - p_left + 1                                    && available width in box
  66. IF LEN(&p_output) > num_cols
  67.    p_output = 'SUBSTR(' + p_output + ',1,num_cols)'                       && shorten output
  68. ENDIF
  69. IF LEN(&p_output) < num_cols
  70.    padding = SPACE( num_cols - LEN(&p_output) )
  71.    p_output = p_output + " + padding"                                     && pad output with spaces
  72. ENDIF
  73.  
  74. IF TYPE('p_row') != 'N'
  75.    p_row = 0
  76. ENDIF
  77.  
  78. IF p_row <= 0                                                          && first time being called by proc
  79.    IF p_row = 0
  80.       IF p_cond = '.T.'                                                && if no condition provided
  81.          GO TOP                                                        && go to top of database
  82.       ELSE
  83.          *-- if the current record does not meet the supplied condition
  84.          IF .NOT. &p_cond
  85.             *-- position the record pointer to EOF()
  86.             GO BOTTOM
  87.             SKIP
  88.          ENDIF
  89.          *-- otherwise, find first record meeting the condition specified
  90.          DO WHILE (&p_cond) .AND. (.NOT. BOF())
  91.             mrec = RECNO()
  92.             SKIP-1
  93.             IF BOF() .OR. (.NOT. (&p_cond))
  94.                GOTO mrec
  95.                EXIT
  96.             ENDIF
  97.          ENDDO
  98.       ENDIF
  99.    ENDIF
  100.    mrec = RECNO()                                                     && x marks the spot
  101.    @ p_top,p_left SAY ' '                                             && put normal video blank, otherwise scroll get reverse
  102.    SCROLL( p_top, p_left, p_bot, p_rite, 0 )                          && clear inside of box to be filled with records
  103.    p_row = p_top                                                      && set up first row for display
  104.    DO WHILE p_row <= p_bot .AND. (&p_cond) .AND. (.NOT. EOF())                       && fill box with available records
  105.       @ p_row,p_left SAY &p_output                                    && from database in normal video
  106.       p_row = p_row + 1
  107.       SKIP
  108.    ENDDO
  109.    p_row = p_top                                                      && set back to first row
  110.    GOTO mrec                                                          && go back to where we started
  111. ENDIF
  112.  
  113. f_rowcount = p_bot - p_top + 1
  114. f_seekstr  = ""                                                       && string to initialize for key searches
  115.  
  116. DO WHILE .T.
  117.    SETCOLOR(f_reverse)
  118.    @ p_row, p_left SAY &p_output
  119.    SETCOLOR(in_color)
  120.  
  121.    *-- do routine if it exists and they are not stomping on a key
  122.    IF do_proc .AND. NEXTKEY() = 0
  123.       DO &p_proc
  124.    ENDIF
  125.    mrec = RECNO()
  126.    lkey = INKEY(0)
  127.  
  128.    DO CASE
  129.  
  130.       CASE lkey = 5
  131.          *-- Up Arrow
  132.          f_seekstr = ''                                             && cancel current search string
  133.          @ p_row, p_left SAY &p_output
  134.          SKIP-1
  135.          IF BOF() .OR. (.NOT. (&p_cond))
  136.             GOTO mrec
  137.             LOOP
  138.          ENDIF
  139.          p_row = p_row - 1
  140.          IF p_row < p_top
  141.             SCROLL( p_top, p_left, p_bot, p_rite, -1 )
  142.             p_row = p_top
  143.          ENDIF
  144.  
  145.       CASE lkey = 24
  146.          *-- DownArrow
  147.          f_seekstr = ''                                             && cancel current search string
  148.          @ p_row, p_left SAY &p_output
  149.          SKIP
  150.          IF EOF() .OR. (.NOT. (&p_cond))
  151.             GOTO mrec
  152.             LOOP
  153.          ENDIF
  154.          p_row = p_row + 1
  155.          IF p_row > p_bot
  156.             SCROLL( p_top, p_left, p_bot, p_rite, 1 )
  157.             p_row = p_bot
  158.          ENDIF
  159.  
  160.       CASE lkey = 27
  161.          *-- EscapeKey
  162.          @ p_row, p_left SAY &p_output
  163.          p_row = 0
  164.          EXIT
  165.  
  166.       CASE lkey = 13
  167.          *-- EnterKey
  168.          SETCOLOR(f_bright)
  169.          @ p_row, p_left SAY &p_output
  170.          SETCOLOR(in_color)
  171.          EXIT
  172.  
  173.       CASE lkey = 18
  174.          *-- PageUp
  175.          f_seekstr = ''                                             && cancel current search string
  176.          FOR counter = 1 TO f_rowcount
  177.             @ p_row,p_left SAY &p_output
  178.             mrec = RECNO()
  179.             SKIP-1
  180.             IF BOF() .OR. (.NOT. (&p_cond))
  181.                GOTO mrec
  182.                SETCOLOR(f_reverse)
  183.                @ p_row,p_left SAY &p_output
  184.                SETCOLOR(in_color)
  185.                EXIT
  186.             ENDIF
  187.             p_row = p_row - 1
  188.             IF p_row < p_top
  189.                SCROLL( p_top, p_left, p_bot, p_rite, -1 )
  190.                p_row = p_top
  191.             ENDIF
  192.             SETCOLOR(f_reverse)
  193.             @ p_row,p_left SAY &p_output
  194.             SETCOLOR(in_color)
  195.          NEXT counter
  196.  
  197.       CASE lkey = 3
  198.          *-- PageDown
  199.          f_seekstr = ''                                             && cancel current search string
  200.          FOR counter = 1 TO f_rowcount
  201.             @ p_row,p_left SAY &p_output
  202.             mrec = RECNO()
  203.             SKIP
  204.             IF EOF() .OR. (.NOT. (&p_cond))
  205.                GOTO mrec
  206.                SETCOLOR(f_reverse)
  207.                @ p_row,p_left SAY &p_output
  208.                SETCOLOR(in_color)
  209.                EXIT
  210.             ENDIF
  211.             p_row = p_row + 1
  212.             IF p_row > p_bot
  213.                SCROLL( p_top, p_left, p_bot, p_rite, 1 )
  214.                p_row = p_bot
  215.             ENDIF
  216.             SETCOLOR(f_reverse)
  217.             @ p_row,p_left SAY &p_output
  218.             SETCOLOR(in_color)
  219.          NEXT counter
  220.  
  221.       CASE lkey = 1
  222.          *-- Home Key
  223.          f_seekstr = ''                                             && cancel current search string
  224.          IF p_cond = '.T.'
  225.             *-- if no condition supplied, go to top of database
  226.             GO TOP
  227.          ELSE
  228.             *-- otherwise, find first record meeting condition
  229.             DO WHILE (&p_cond) .AND. (.NOT. BOF())
  230.                mrec = RECNO()
  231.                SKIP-1
  232.                IF BOF() .OR. (.NOT. (&p_cond))
  233.                   GOTO mrec
  234.                   EXIT
  235.                ENDIF
  236.             ENDDO
  237.          ENDIF
  238.          *-- now clear window and display records
  239.          mrec = RECNO()
  240.          @ p_top,p_left SAY ' '                                         && put normal video blank, otherwise scroll get reverse
  241.          SCROLL( p_top, p_left, p_bot, p_rite, 0 )                  && clear inside of box to be filled with records
  242.          p_row = p_top
  243.          DO WHILE p_row <= p_bot .AND. (&p_cond) .AND. (.NOT. EOF())
  244.             @ p_row,p_left SAY &p_output
  245.             p_row = p_row + 1
  246.             SKIP
  247.          ENDDO
  248.          p_row = p_top
  249.          GOTO mrec
  250.  
  251.       CASE lkey = 6
  252.          *-- End Key
  253.          f_seekstr = ''                                             && cancel current search string
  254.          lkey = 0
  255.          DO WHILE lkey = 0 .AND. (&p_cond) .AND. (.NOT. EOF())
  256.             @ p_row,p_left SAY &p_output
  257.             mrec = RECNO()
  258.             SKIP
  259.             IF EOF() .OR. (.NOT. (&p_cond))
  260.                GOTO mrec
  261.                SETCOLOR(f_reverse)
  262.                @ p_row,p_left SAY &p_output
  263.                SETCOLOR(in_color)
  264.                EXIT
  265.             ENDIF
  266.             p_row = p_row + 1
  267.             IF p_row > p_bot
  268.                SCROLL( p_top, p_left, p_bot, p_rite, 1 )
  269.                p_row = p_bot
  270.             ENDIF
  271.             SETCOLOR(f_reverse)
  272.             @ p_row,p_left SAY &p_output
  273.             SETCOLOR(in_color)
  274.             lkey = INKEY()
  275.          ENDDO
  276.  
  277.       CASE lkey = 22
  278.          *-- Insert Key
  279.          SETCOLOR(in_color)
  280.          @ p_row, p_left SAY &p_output
  281.          EXIT
  282.  
  283.       CASE lkey = 7
  284.          *-- Delete Key
  285.          EXIT
  286.  
  287. *      CASE lkey = 28
  288. *         *-- F1 = Help Key
  289. *         DO Help WITH PROCNAME(), PROCLINE(), "LKEY"
  290.  
  291.       CASE lkey > 31 .AND. lkey < 127                                     && printable character range
  292.          IF EMPTY(INDEXKEY(0))                                            && if no index is controlling
  293.             LOOP                                                          && skip this proc
  294.          ENDIF
  295.          mrec = RECNO()                                                   && save record number
  296.          f_seekstr = f_seekstr + UPPER(CHR(lkey))
  297.          SEEK f_seekstr                                                  && seek upper case first
  298.          IF EOF() .OR. (.NOT. (&p_cond))
  299.             SEEK LOWER(f_seekstr)                                                && try finding lower case match
  300.             IF EOF() .OR. (.NOT. (&p_cond))
  301.                f_seekstr = ''
  302.                GOTO mrec
  303.                ?? CHR(7)
  304.                LOOP
  305.             ENDIF
  306.          ENDIF
  307.          mrec = RECNO()
  308.          @ p_top,p_left SAY ' '                                       && put normal video blank, otherwise scroll get reverse
  309.          SCROLL( p_top, p_left, p_bot, p_rite, 0 )                && clear inside of box to be filled with records
  310.          p_row = p_top                                                   && set up first row for display
  311.          DO WHILE p_row <= p_bot .AND. (&p_cond) .AND. (.NOT. EOF())                     && fill box with available records
  312.             @ p_row,p_left SAY &p_output                                   && from database in normal video
  313.             p_row = p_row + 1
  314.             SKIP
  315.          ENDDO
  316.          p_row = p_top                                                   && set back to first row
  317.          GOTO mrec
  318.  
  319.    ENDCASE
  320. ENDDO
  321. SETCOLOR(in_color)
  322. RETURN (p_row)
  323.  
  324.